home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swagg_m.zip / MISC.SWG / 0066_dBase Manipulation.pas < prev    next >
Pascal/Delphi Source File  |  1994-01-27  |  9KB  |  378 lines
  1. {
  2. { If this code is used commercially, please send a few bucks to      }
  3. { Bill Himmelstoss, PO BOX 23246, Jacksonville, FL  32241-3246,      }
  4. { Otherwise, it's freely distributable.                              }
  5.  
  6. unit DBF;
  7.  
  8. interface
  9.  
  10. uses
  11.   Objects,
  12.   OString;
  13.  
  14. type
  15.   TYMDDate = record
  16.     Year,
  17.     Month,
  18.     Day: Byte;
  19.   end;
  20.  
  21.   PDatabase = ^TDatabase;
  22.   TDatabase = object(TObject)
  23.     DatabaseType: Byte;
  24.     LastUpdate: TYMDDate;
  25.     NumRecords: Longint;
  26.     FirstRecordPos: Word;
  27.     RecordLength: Word;
  28.  
  29.     S: TDosStream;
  30.     Pathname: TOString;
  31.     Modified: Boolean;
  32.     Fields: TCollection;
  33.  
  34.     constructor Init(APathname: TOString);
  35.     constructor InitCreate(APathname: TOString; AFields: PCollection);
  36.     destructor Done; virtual;
  37.     procedure RefreshHeader;
  38.     procedure UpdateHeader;
  39.     function GetRecord(RecordNum: Longint): Pointer;
  40.     procedure PutRecord(RecordNum: Longint; Rec: Pointer);
  41.     procedure Append(Rec: Pointer);
  42.     procedure Zap;
  43.     procedure RefreshFields;
  44.   end;
  45.  
  46.   PFieldDef = ^TFieldDef;
  47.   TFieldDef = object(TObject)
  48.     Name: TOString;
  49.     DataType: Char;
  50.     Displacement: Longint;
  51.     Length: Byte;
  52.     Decimal: Byte;
  53.  
  54.     constructor Init(
  55.       AName: String;
  56.       ADataType: Char;
  57.       ALength,
  58.       ADecimal: Byte);
  59.     destructor Done; virtual;
  60.     constructor Load(var S: TStream);
  61.     procedure Store(var S: TStream);
  62.   end;
  63.  
  64. implementation
  65.  
  66. uses
  67.   WinDos;
  68.  
  69. constructor TDatabase.Init(APathname: TOString); begin
  70.   inherited Init;
  71.   Pathname.InitText(APathname);
  72.   S.Init(Pathname.CString, stOpen);
  73.   if S.Status <> stOk then Fail;
  74.   Fields.Init(5, 5);
  75.   RefreshHeader;
  76. end;
  77.  
  78. constructor TDatabase.InitCreate(APathname: TOString; AFields: PCollection);
  79. const
  80.   Terminator: Byte = $0D;
  81. var
  82.   Year, Month, Day, Dummy: Word;
  83.  
  84.   procedure CopyField(Item: PFieldDef); far;
  85.   begin
  86.     Fields.Insert(Item);
  87.   end;
  88.  
  89.   procedure WriteFieldSubrecord(Item: PFieldDef); far;
  90.   begin
  91.     Item^.Store(S);
  92.     Inc(RecordLength, Item^.Length);
  93.   end;
  94.  
  95. begin
  96.   inherited Init;
  97.  
  98.   DatabaseType := $03;
  99.   GetDate(Year, Month, Day, Dummy);
  100.   LastUpdate.Year := Year - 1900;
  101.   LastUpdate.Month := Month;
  102.   LastUpdate.Day := Day;
  103.   NumRecords := 0;
  104.   RecordLength := 0;
  105.  
  106.   Pathname.InitText(APathname);
  107.   S.Init(Pathname.CString, stCreate);
  108.   if S.Status <> stOk then Fail;
  109.   UpdateHeader;
  110.  
  111.   S.Seek(32); { beginning of field subrecords }
  112.   Fields.Init(AFields^.Count, 5);
  113.   AFields^.ForEach(@CopyField);
  114.   Fields.ForEach(@WriteFieldSubrecord);
  115.  
  116.   S.Write(Terminator, SizeOf(Terminator));
  117.   Modified := true;
  118.   FirstRecordPos := S.GetPos;
  119.   UpdateHeader;
  120. end;
  121.  
  122. destructor TDatabase.Done;
  123. begin
  124.   if Modified then UpdateHeader;
  125.   Pathname.Done;
  126.   S.Done;
  127.   Fields.Done;
  128.   inherited Done;
  129. end;
  130.  
  131. procedure TDatabase.RefreshHeader;
  132. var
  133.   OldPos: Longint;
  134. begin
  135.   OldPos := S.GetPos;
  136.   S.Seek(0);
  137.   S.Read(DatabaseType, SizeOf(DatabaseType));
  138.   S.Read(LastUpdate, SizeOf(LastUpdate));
  139.   S.Read(NumRecords, SizeOf(NumRecords));
  140.   S.Read(FirstRecordPos, SizeOf(FirstRecordPos));
  141.   S.Read(RecordLength, SizeOf(RecordLength));
  142.   S.Seek(OldPos);
  143.   RefreshFields;
  144. end;
  145.  
  146. procedure TDatabase.UpdateHeader;
  147. var
  148.   OldPos: Longint;
  149.   Reserved: array[12..31] of Char;
  150. begin
  151.   OldPos := S.GetPos;
  152.   S.Seek(0);
  153.   S.Write(DatabaseType, SizeOf(DatabaseType));
  154.   S.Write(LastUpdate, SizeOf(LastUpdate));
  155.   S.Write(NumRecords, SizeOf(NumRecords));
  156.   S.Write(FirstRecordPos, SizeOf(FirstRecordPos));
  157.   S.Write(RecordLength, SizeOf(RecordLength));
  158.   FillChar(Reserved, SizeOf(Reserved), #0);
  159.   S.Write(Reserved, SizeOf(Reserved));
  160.   S.Seek(OldPos);
  161. end;
  162.  
  163. function TDatabase.GetRecord(RecordNum: Longint): Pointer; var
  164.   Temp: Pointer;
  165.   Pos: Longint;
  166. begin
  167.   Temp := NIL;
  168.   GetMem(Temp, RecordLength);
  169.   if Temp <> NIL then
  170.   begin
  171.     Pos := FirstRecordPos + ((RecordNum - 1) * RecordLength);
  172.     if S.GetPos <> Pos then
  173.       S.Seek(Pos);
  174.     S.Read(Temp^, RecordLength);
  175.   end;
  176.   GetRecord := Temp;
  177. end;
  178.  
  179. procedure TDatabase.Append(Rec: Pointer); begin
  180.   if Assigned(Rec) then
  181.   begin
  182.     Modified := true;
  183.     Inc(NumRecords);
  184.     PutRecord(NumRecords, Rec);
  185.   end;
  186. end;
  187.  
  188. procedure TDatabase.PutRecord(RecordNum: Longint; Rec: Pointer); var
  189.   Pos: Longint;
  190. begin
  191.   if Assigned(Rec) and (RecordNum <= NumRecords) then
  192.   begin
  193.     Pos := FirstRecordPos + ((RecordNum - 1) * RecordLength);
  194.     if S.GetPos <> Pos then
  195.       S.Seek(Pos);
  196.     S.Write(Rec^, RecordLength);
  197.   end;
  198. end;
  199.  
  200. procedure TDatabase.Zap;
  201. var
  202.   T: TDosStream;
  203.   Temp, D, N, E: TOString;
  204.   F: File;
  205. begin
  206.   D.Init(fsDirectory);
  207.   N.Init(fsFilename);
  208.   E.Init(fsExtension);
  209.   FileSplit(Pathname.CString, D.CString, N.CString, E.CString);
  210.   D.RecalcLength;
  211.   N.RecalcLength;
  212.   E.RecalcLength;
  213.   Temp.InitText(D);
  214.   Temp.Append(N);
  215.   Temp.AppendP('.TMP');
  216.   D.Done;
  217.   N.Done;
  218.   E.Done;
  219.  
  220.   T.Init(Temp.CString, stCreate);
  221.   S.Seek(0);
  222.   T.CopyFrom(S, FirstRecordPos - 1);
  223.   T.Done;
  224.   S.Done;
  225.   Assign(F, Pathname.CString);
  226.   Erase(F);
  227.   Assign(F, Temp.CString);
  228.   Rename(F, Pathname.CString);
  229.   S.Init(Pathname.CString, stOpen);
  230.   NumRecords := 0;
  231.   Modified := false;
  232.   UpdateHeader;
  233. end;
  234.  
  235. procedure TDatabase.RefreshFields;
  236. var
  237.   Terminator: Byte;
  238.   HoldPos: Longint;
  239.   FieldDef: PFieldDef;
  240. begin
  241.   S.Seek(32); { beginning of Field subrecords }
  242.  
  243.   repeat
  244.     HoldPos := S.GetPos;
  245.     S.Read(Terminator, SizeOf(Terminator));
  246.     if Terminator <> $0D then
  247.     begin
  248.       S.Seek(HoldPos);
  249.       FieldDef := New(PFieldDef, Load(S));
  250.       Fields.Insert(FieldDef);
  251.     end;
  252.   until Terminator = $0D;
  253. end;
  254.  
  255. constructor TFieldDef.Init(
  256.   AName: String;
  257.   ADataType: Char;
  258.   ALength,
  259.   ADecimal: Byte);
  260. begin
  261.   inherited Init;
  262.   Name.InitTextP(AName);
  263.   DataType := ADataType;
  264.   Length := ALength;
  265.   Decimal := ADecimal;
  266.   Displacement := 0;
  267. end;
  268.  
  269. destructor TFieldDef.Done;
  270. begin
  271.   Name.Done;
  272.   inherited Done;
  273. end;
  274.  
  275. constructor TFieldDef.Load(var S: TStream); var
  276.   AName: array[1..11] of Char;
  277.   Reserved: array[18..31] of Char;
  278. begin
  279.   S.Read(AName, SizeOf(AName));
  280.   Name.Init(SizeOf(AName));
  281.   Name.SetText_(@AName[1], 11);
  282.   S.Read(DataType, SizeOf(DataType));
  283.   S.Read(Displacement, Sizeof(Displacement));
  284.   S.Read(Length, SizeOf(Length));
  285.   S.Read(Decimal, SizeOf(Decimal));
  286.   S.Read(Reserved, SizeOf(Reserved));
  287. end;
  288.  
  289. procedure TFieldDef.Store(var S: TStream); var
  290.   Reserved: array[18..31] of Char;
  291. begin
  292.   S.Write(Name.CString^, 11);
  293.   S.Write(DataType, SizeOf(DataType));
  294.   S.Write(Displacement, Sizeof(Displacement));
  295.   S.Write(Length, SizeOf(Length));
  296.   S.Write(Decimal, SizeOf(Decimal));
  297.   FillChar(Reserved, SizeOf(Reserved), #0);
  298.   S.Write(Reserved, SizeOf(Reserved));
  299. end;
  300.  
  301. end.
  302.  
  303.  
  304.  
  305.  
  306.  
  307. program DbfTest;
  308.  
  309. uses
  310.   dbf, wincrt, ostring, objects, strings;
  311.  
  312. type
  313.   PDbfTest = ^TDbfTest;
  314.   TDbfTest = record
  315.     Deleted: Char; { ' '=no, '*'=yes }
  316.     AcctNo: array[1..16] of Char;
  317.     Chunk: array[1..8] of Char;
  318.     Baskard: array[1..5] of Char;
  319.     Extra: array[1..8] of Char;
  320.     Sandwich: array[1..25] of Char;
  321.   end;
  322.  
  323. var
  324.   rec: PDbfTest;
  325.   database: tdatabase;
  326.   pathname: tostring;
  327.   temp: string;
  328.   fields: tcollection;
  329.  
  330.   procedure DoShow;
  331.  
  332.     procedure show(item: pfielddef); far;
  333.     begin
  334.       writeln(
  335.         item^.name.cstring:15, ' ',
  336.         item^.datatype, ' ',
  337.         item^.length:10, ' ',
  338.         item^.decimal:10, ' ');
  339.     end;
  340.  
  341.   begin
  342.     database.fields.foreach(@show);
  343.   end;
  344.  
  345.  
  346. begin
  347.   InitWinCrt;
  348.  
  349.   fields.init(5, 0);
  350.   fields.insert(new(pfielddef, init('ACCTNO',   'C', 16, 0)));
  351.   fields.insert(new(pfielddef, init('CHUNK',    'N',  8, 2)));
  352.   fields.insert(new(pfielddef, init('BASKARD',  'C',  5, 0)));
  353.   fields.insert(new(pfielddef, init('EXTRA',    'D',  8, 0)));
  354.   fields.insert(new(pfielddef, init('SANDWICH', 'C', 25, 0)));
  355.   pathname.inittextp('c:\dbftest.dbf');
  356.   database.initcreate(pathname, @fields);
  357.   pathname.done;
  358.   DoShow;
  359.  
  360.   New(Rec);
  361.   with Rec^ do
  362.   begin
  363.     Acctno   := '1313558000001005'; { <-will self-check, but not valid }
  364.     Chunk    := '   10.00';
  365.     Baskard  := 'ABCDE';
  366.     Extra    := '19931125';
  367.     Sandwich := 'Turkey Leftovers         ';
  368.   end;
  369.   database.append(rec);
  370.   dispose(rec);
  371.  
  372.   rec := database.getrecord(1);
  373.   writeln(rec^.acctno, ' ', rec^.Sandwich);
  374.   dispose(rec);
  375.  
  376.   database.done;
  377. end.
  378.